home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / install.tcl < prev    next >
Encoding:
Text File  |  2000-12-27  |  27.1 KB  |  831 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "install.tcl"
  6.  #                                    created: 25/7/97 {1:12:02 am} 
  7.  #                                last update: 12/27/2000 {11:25:45 AM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-2000  Vince Darley, all rights reserved
  15.  # 
  16.  #  This file contains a pretty complex package installation
  17.  #  procedure, and some more rudimentary code which queries
  18.  #  an ftp site for a list of packages and checks dates etc
  19.  #  to see if there's something new.  The idea being you can
  20.  #  then just select from a menu to download and subsequently
  21.  #  install.
  22.  #  
  23.  # Package installation:
  24.  # 
  25.  #  There is a new install mode 'Inst' which adds the Install menu.
  26.  #  Install mode is trigerred when a file's name ends in 'Install'
  27.  #  or 'INSTALL', or when the first line of the file contains the
  28.  #  letters 'install', provided in this last case, that the file
  29.  #  is not in Alpha's Tcl hierarchy.  This last case is useful so
  30.  #  that a single .tcl file can be a package and be installed by
  31.  #  Alpha using these nice scripts, without the need for a separate
  32.  #  install-script-file.  However once that .tcl file is installed,
  33.  #  if you open it you certainly wouldn't want it opened in Install mode!
  34.  #  
  35.  # Once you've opened a file in install mode:
  36.  # 
  37.  #  You can select 'install this package' from the menu.  (If the file's
  38.  #  first line contains 'auto-install' the menu item is automatically
  39.  #  selected, provided no modifier key is pressed).  In any case, this 
  40.  #  does the following: if there's an install file in the current directory
  41.  #  it is sourced.  An install file is defined as a file at the same
  42.  #  level as the current file whose name matches "*install*.tcl".
  43.  #  If no install file is found, a default (but still rather
  44.  #  sophisticated) installation takes place, by calling the procedure
  45.  #  'install::packageInstallationDialog'.  Any install script in your
  46.  #  *install*.tcl file may wish to use that procedure anyway.  For
  47.  #  instance, the installer for Vince's Additions uses just the
  48.  #  following lines in its installation file:
  49.  #  
  50.  #     install::packageInstallationDialog "Vince's Additions" "\
  51.  # These additions include a number of different packages, designed to \
  52.  # make using Alpha an even more pleasant experience!  They include a \
  53.  # more sophisticated completion and template mechanism, some bibliography \
  54.  # conversion routines, and a general projects/documents organisation scheme." 
  55.  #     
  56.  # In any case, 'install::packageInstallationDialog' does the following:
  57.  # It scans the current directory for files which may need installing.
  58.  # This includes any .tcl file which is not the *install*.tcl script.
  59.  # It also includes the same in any subdirectories of the current 
  60.  # directory.  Intelligent guesses are made as to whether files are 
  61.  # Modes, Menus, Packages, Completions, Extensions, Help files or
  62.  # UserModifications.
  63.  # 
  64.  # Extensions are *+\d.tcl files, these go in tclExtensionsFolder
  65.  # Modes are *Mode.tcl files, or all files in a subdir *Mode*
  66.  # Menus are *Menu.tcl files, or all files in a subdir *Menu*
  67.  # Completions are all files *Completions.tcl
  68.  # Help files end in 'help' or 'tutorial' (any case)
  69.  # UserModifications are any files in a UserModifications subdir.
  70.  # Packages are anything else.
  71.  # 
  72.  # UserModifications are files which a package installs once, but
  73.  # the user is expected to edit afterwards.  Hence if the package
  74.  # is reinstalled, those files are not overwritten.
  75.  # 
  76.  # Clearly if the original install file was in fact a .tcl file on
  77.  # its own (with 'install' in the first line) then we don't search
  78.  # the directory in which it sits.  This is now implemented.
  79.  # 
  80.  # ----------
  81.  # OK, we've got all the files and worked out where they should go.
  82.  # Now we build an installation dialog, from which the user can
  83.  # select 'Easy Install', or 'Custom Install'.  Easy install does
  84.  # the works, custom allows the user to choose amongst all the 
  85.  # available sub-pieces.  A sub-piece is any single item in the
  86.  # install directory: so you can package up blocks of files as a single
  87.  # package by putting them in a sub-dir.
  88.  # 
  89.  # If you hit 'Ok' installation takes place, with optional backup
  90.  # of removed files.
  91.  # 
  92.  # Currently package indices and tcl indices are then rebuilt.  This
  93.  # last thing needs to be a bit more sophisticated...
  94.  # 
  95.  # ----------
  96.  # Caveats:
  97.  # 
  98.  #     Currently not clever enough to install, say, HTML mode in the
  99.  #     way it currently is: here we wish to install all HTML files in
  100.  #     one sub-dir of the Modes dir, but we wish to allow the user to
  101.  #     pick which sub-sets of files will go in that 'HTML and CSS modes'
  102.  #     directory.  So the user could install just HTML files and ignore
  103.  #     the CSS ones.  The solution I propose is to store such items in
  104.  #     separate subfolder of the base HTML subfolder.  Such items would
  105.  #     then be sub-choices of the base 'install HTML mode' choice, and
  106.  #     when installed, would be installed directly into the HTML mode
  107.  #     dir.
  108.  #     
  109.  # I think I need more feedback before embarking on further 
  110.  # modifications to this code.
  111.  #  
  112.  # ###################################################################
  113.  ##
  114.         
  115. namespace eval install {}
  116.  
  117. proc installMenu {} {}
  118.  
  119. set installMenu "Install"
  120. set menu::items(Install) [list \
  121.   "installThisPackage" "(-" "rebuildPackageIndices" "rebuildTclIndices"]
  122.  
  123. menu::buildSome Install
  124.  
  125. proc install::rebuildPackageIndices {} { alpha::rebuildPackageIndices }
  126.  
  127. ## 
  128.  # -------------------------------------------------------------------------
  129.  # 
  130.  # "install::installThisPackage" --
  131.  # 
  132.  #  DO NOT CALL THIS PROCEDURE FROM YOUR *install.tcl INSTALLATION SCRIPT
  133.  #  IT WILL CAUSE INFINITE RECURSION AND CRASH ALPHA.  THIS PROCEDURE IS
  134.  #  DESIGNED TO SOURCE YOUR *install.tcl FILE AUTOMATICALLY IF IT EXISTS.
  135.  #  
  136.  #  Instead call install::packageInstallationDialog 
  137.  #  and install::askRebuildQuit
  138.  # -------------------------------------------------------------------------
  139.  ##
  140. proc install::installThisPackage {} {
  141.     # single-file packages by definition don't have an installer.
  142.     if {[file extension [set name [install::name]]] == ".tcl"} {
  143.     install::packageInstallationDialog "Package"
  144.     } else {        
  145.     set currD [file dirname $name]
  146.     if {[regexp -nocase {auto-install-script} [getText [minPos] [nextLineStart [minPos]]]]} {
  147.         set installer [list $name]
  148.     } else {
  149.         set installer [glob -nocomplain -dir $currD *nstall*.tcl]
  150.         if {[llength $installer] > 1} {
  151.         alertnote "This package has two installation files.  This is bad; I'll do a standard installaton."
  152.         }
  153.     }
  154.     
  155.     if {[llength $installer] == 1} {
  156.         global installation_dir
  157.         set installation_dir $currD
  158.         # installer is a one-item list, so no need to wrap it
  159.         uplevel \#0 source $installer
  160.         unset installation_dir
  161.     } else {
  162.         install::packageInstallationDialog "Package"
  163.     }
  164.     }
  165.     global install::forcequit install::nochanges
  166.     if {![info exists install::nochanges] || !${install::nochanges}}  {
  167.     catch {unset install::nochanges}
  168.     if {[info exists install::forcequit]} {
  169.         # Will exist unless installation was aborted
  170.         install::askRebuildQuit ${install::forcequit}
  171.     }
  172.     } else {
  173.     unset install::nochanges
  174.     message "Installation complete (nothing was actually installed)"
  175.     }
  176. }
  177.  
  178. proc install::sourceUpdatedSystem {} {
  179.     global HOME install::time
  180.     if {![info exists install::time]} { return }
  181.     foreach f [glob -nocomplain -dir [file join ${HOME} Tcl SystemCode] *.tcl] {
  182.     if {[file tail $f] == "AlphaBits.tcl" \
  183.       || [file tail $f] == "alphaDefinitions.tcl"} {continue}
  184.     getFileInfo $f info
  185.     if {$info(modified) > ${install::time}} {
  186.         catch [list uplevel \#0 [list source $f]]
  187.     }
  188.     }
  189. }
  190.  
  191. proc install::askRebuildQuit {{force 0}} {
  192.     if {$force != 2} {
  193.     alertnote "All indices must now be rebuilt for the installation to work."
  194.     if {![key::optionPressed] \
  195.       || [dialog::yesno "Shall I rebuild the indices?"]} {
  196.         install::sourceUpdatedSystem
  197.         set n [alpha::package names]
  198.         alpha::rebuildPackageIndices
  199.         set new [lremove -l [alpha::package names] $n]
  200.         if {![key::optionPressed] \
  201.           || [dialog::yesno "Shall I rebuild the Tcl indices?"]} {
  202.         rebuildTclIndices
  203.         }
  204.         auto_reset
  205.         if {[llength $new]} {
  206.         if {[dialog::yesno "You just installed the following new packages: $new; do you want to activate them at next startup?"]} {
  207.             global global::features
  208.             eval lappend global::features $new
  209.         }
  210.         }
  211.     }
  212.     }
  213.     if {$force || [dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  214.     if {$force == 2} {
  215.         alertnote "Alpha will now quit.  Package indices will be rebuilt next time you use Alpha."
  216.     } elseif {$force == 1} {
  217.         alertnote "Alpha must now quit."
  218.     }
  219.     if {[win::CurrentTail] == "Installation report"} {
  220.         setWinInfo read-only 0
  221.         setWinInfo dirty 1
  222.     }
  223.     quit
  224.     }
  225. }
  226.  
  227. ## 
  228.  # -------------------------------------------------------------------------
  229.  # 
  230.  # "install::openHook" --
  231.  # 
  232.  #  Used when opening an install file to check for an 'auto-install' line.
  233.  # -------------------------------------------------------------------------
  234.  ##
  235. proc install::openHook {name} {
  236.     if {![getModifiers] && [regexp -nocase {auto-install} [getText [minPos] [nextLineStart [minPos]]]]} {
  237.     moveWin $name 10000 10000
  238.     global install::_name
  239.     set install::_name $name
  240.     catch {install::installThisPackage}
  241.     unset install::_name
  242.     if {![catch {bringToFront $name}]} {
  243.         killWindow
  244.     }
  245.     }
  246. }
  247.  
  248. proc install::editHook {filename} {
  249.     global install::_name
  250.     set install::_name $filename
  251.     catch {install::installThisPackage}
  252.     unset install::_name
  253.     return 1
  254. }
  255.  
  256. proc install::name {} {
  257.     global install::_name
  258.     if {[info exists install::_name]} {
  259.     return ${install::_name}
  260.     } else {
  261.     return [win::Current]
  262.     }
  263. }
  264.  
  265. proc install::readAtStartup {w} {
  266.     global alpha::readAtStartup modifiedVars
  267.     lappend alpha::readAtStartup $w
  268.     lappend modifiedVars alpha::readAtStartup
  269. }
  270.  
  271. ## 
  272.  # -------------------------------------------------------------------------
  273.  # 
  274.  # "install::packageInstallationDialog" --
  275.  # 
  276.  #  Optional arguments are as follows:
  277.  #  
  278.  #  -ignore {list of files to ignore}
  279.  #  -remove {list of files to remove from Alpha hierarchy}    
  280.  #  -rebuildquit '0 or 1'  
  281.  #      (prompts the user to rebuild indices and quit; default 1)
  282.  #  -require {Pkg version Pkg version …}
  283.  #      e.g. -require {Alpha 6.52 elecCompletions 7.99}
  284.  #  -provide {Pkg version Pkg version …}
  285.  #  -forcequit '0' or '1' or '2'.
  286.  #  
  287.  #  Note: -forcequit 2 is really only designed for use by Alpha Core
  288.  #  updaters; it should not really be used by other code.
  289.  #  
  290.  #  and 
  291.  #  
  292.  #  -SystemCode -Modes -Menus
  293.  #  -BugFixes -Completions -Packages
  294.  #  -ExtensionsCode -UserModifications -Tools -Tests
  295.  #  
  296.  #  which force the placement of the following list of files.
  297.  # -------------------------------------------------------------------------
  298.  ##
  299. proc install::packageInstallationDialog {{pkgname "Package"} {description ""} args} {
  300.     set win::Current [install::name]
  301.     set currD [file dirname ${win::Current}]
  302.     if {[file extension ${win::Current}] == ".tcl"} {
  303.     # single file to install
  304.     set pkgname [file root [file tail ${win::Current}]]
  305.     set description "I'll install this single-file package, placing\
  306.       it in its correct location in Alpha's code base."
  307.     set rebuild [eval [list install::_packageInstallationDialog $pkgname $description \
  308.       $currD [list [file tail ${win::Current}]]] $args]
  309.     } else {        
  310.     global file::separator
  311.     set toplevels [glob -nocomplain -dir $currD *.tcl]
  312.     eval lappend toplevels [glob -nocomplain -dir $currD *.shlb]
  313.     eval lappend toplevels [glob -types TEXT -nocomplain -dir $currD "* *"]
  314.     set toplevels [lremove -glob $toplevels *\[Ii\]nstall*]
  315.     set toplevels [lremove -glob $toplevels *INSTALL*]
  316.     set subdirs [glob -nocomplain -types d -dir $currD *]
  317.     foreach item $toplevels {
  318.         # Tcl 8 doesn't have functional glob -types TEXT yet
  319.         if {![file isdirectory $item]} {
  320.         lappend items [file tail $item]
  321.         }
  322.     }
  323.     if {[file exists [file join $currD Changes]]} {
  324.         lappend items Changes
  325.     }
  326.     foreach dir $subdirs {
  327.         lappend items "[file tail ${dir}]${file::separator}"
  328.     }
  329.     set subdirs [lremove -glob $subdirs "*Completions${file::separator}"]
  330.     set completions [glob -nocomplain -types d -dir $currD Completions]
  331.     set usermods [glob -nocomplain -types d -dir $currD UserModifications]
  332.     eval [list install::_packageInstallationDialog $pkgname $description \
  333.       $currD $items] $args
  334.     }
  335. }
  336.  
  337. proc install::_packageInstallationDialog {pkgname description currD items args} {
  338.     global install::time file::separator install::force_overwrite
  339.     set install::time [now]
  340.     set install_types [list SystemCode CorePackages Examples \
  341.       Modes Menus BugFixes SharedLibs Completions Packages Home AlphaCore \
  342.       ExtensionsCode UserModifications Help QuickStart Tools Tests remove]
  343.     set opts(-ignore) ""
  344.     set opts(-forcequit) 0
  345.     set opts(-require) ""
  346.     foreach type $install_types {
  347.     set opts(-$type) ""
  348.     }
  349.     getOpts [concat provide ignore require rebuildquit forcequit $install_types]
  350.     
  351.     set assigned ""
  352.     foreach type $install_types {
  353.     if {$opts(-$type) != ""} {
  354.         eval lappend assigned $opts(-$type)
  355.         set $type $opts(-$type)
  356.     }
  357.     }
  358.     # check if package requires others:
  359.     array set req $opts(-require)
  360.     foreach pkg [array names req] {
  361.     eval package::reqInstalledVersion [list $pkg] $req($pkg)
  362.     }
  363.     catch {unset req}
  364.     unset opts(-require)
  365.     # check on -provide option
  366.     if {[info exists opts(-provide)]} {
  367.     array set prov $opts(-provide)
  368.     foreach pkg [array names prov] {
  369.         # check currently installed version isn't newer
  370.         if {![catch {alpha::package versions $pkg} v]} {
  371.         switch -- [alpha::package vcompare $v $prov($pkg)] {
  372.             0 {
  373.             alertnote "Package $pkg version $v is already installed.\
  374.               You may wish to cancel the installation."
  375.             }
  376.             1 {
  377.             alertnote "This installer is for $pkg version $prov($pkg)\
  378.               but version $v is already installed. You may wish to\
  379.               cancel the installation."
  380.             }
  381.         }
  382.         }
  383.     }
  384.     catch {unset prov}
  385.     unset opts(-provide)
  386.     }
  387.     # check if package has over-ridden default
  388.     global install::forcequit
  389.     set install::forcequit $opts(-forcequit)
  390.     catch {unset opts(-rebuildquit)}
  391.     unset opts(-forcequit)
  392.     # Now assume packages/modes are sub-dirs, completions are in the
  393.     # Completions dir, and toplevels are obvious from their name.
  394.     # (Mode, Menu, BugFixes or default is in Packages dir)
  395.     
  396.     # Create a dialog:
  397.     if {$description == ""} {
  398.     set description "I'll do a complete installation, placing all modes,\
  399.       menus, completions, help files, tools, extensions and packages\
  400.       in their correct locations.  In addition, any core bug fixes\
  401.       this package contains will be patched into\
  402.       Alpha's core Tcl code."
  403.     }
  404.     set y 80
  405.     set names [list "Easy Install" "Custom Install"]
  406.     lappend dial -n [lindex $names 0]
  407.     eval lappend dial \
  408.       [dialog::text "$description" 15 y 55]
  409.     incr y 10
  410.     eval lappend dial \
  411.       [dialog::checkbox "Backup removed files" 1 20 y]
  412.     eval lappend dial \
  413.       [dialog::checkbox "Show installation log" 1 20 y]
  414.     eval lappend dial \
  415.       [dialog::checkbox "Force overwrite, even of newer files" 0 20 y]
  416.     incr y 22
  417.     eval lappend dial \
  418.       [dialog::text "Click OK to continue with the installation" 15 y]
  419.     if {${install::forcequit}} {
  420.     eval lappend dial \
  421.       [dialog::text "Alpha will quit after this installation." 15 y]
  422.     }  
  423.     set othery [expr {$y +10}]
  424.     lappend dial -n [lindex $names 1]
  425.     set y 60
  426.     eval lappend dial \
  427.       [dialog::checkbox "Backup removed files" 1 20 y]
  428.     eval lappend dial \
  429.       [dialog::checkbox "Show installation log" 1 20 y]
  430.     eval lappend dial \
  431.       [dialog::checkbox "Force overwrite, even of newer files" 0 20 y]
  432.     incr y 5
  433.     # Don't install MacOS invisible folder Icon files, if they
  434.     # have been picked up.
  435.     lappend opts(-ignore) "Iconm" "Icon"
  436.     foreach item $items {
  437.     if {[lsearch $opts(-ignore) $item] != -1 \
  438.       || [lsearch $assigned $item] != -1} {
  439.         continue
  440.     }
  441.     if {[string match *+*.tcl $item]} { 
  442.         lappend ExtensionsCode $item 
  443.     } elseif {[regexp "SystemCode" $item]} { 
  444.         lappend SystemCode $item 
  445.     } elseif {[regexp "AlphaCore" $item]} { 
  446.         lappend AlphaCore $item 
  447.     } elseif {$item == "Changes" || [string match "Writing *" $item]} { 
  448.         lappend Help $item 
  449.     } elseif {[regexp "(H|h)elp(/|:)?$" $item]} {
  450.         lappend Help $item 
  451.     } elseif {[regexp -nocase "quick *start$" $item]} {
  452.         lappend QuickStart $item 
  453.     } elseif {[regexp ".*Examples(/|:)?$" $item]} { 
  454.         lappend Examples $item 
  455.     } elseif {[regexp "Modes(/|:)?$" $item]} { 
  456.         lappend Modes $item 
  457.     } elseif {[regexp "Menus(/|:)?$" $item]} { 
  458.         lappend Menus $item 
  459.     } elseif {[regexp "Docs(/|:)" $item]} { 
  460.         lappend Home $item 
  461.     } elseif {[regexp "Tests" $item]} { 
  462.         lappend Tests $item 
  463.     } elseif {[regexp "Tools" $item]} { 
  464.         lappend Tools $item 
  465.     } elseif {[regexp -nocase {mode(:|/|\.tcl)?$} $item]} { 
  466.         lappend Modes $item 
  467.     } elseif {[regexp -nocase {menu(:|/|\.tcl)?$} $item]} { 
  468.         lappend Menus $item 
  469.     } elseif {[regexp -nocase "bugfixes" $item]} {
  470.         lappend BugFixes $item
  471.     } elseif {[regexp "Completions" $item]} {
  472.         lappend Completions $item
  473.     } elseif {[regexp "UserModifications" $item]} {
  474.         lappend UserModifications $item
  475.     } elseif {[regexp "CorePackages" $item]} {
  476.         lappend CorePackages $item
  477.     } elseif {[regexp ".shlb\$" $item]} {
  478.         lappend SharedLibs $item
  479.     } else {
  480.         lappend Packages $item
  481.     }
  482.     }
  483.     set x 20
  484.     set continue 0
  485.     foreach items $install_types {
  486.     if {[info exists $items]} {
  487.         if {$continue} {
  488.         set continue 0
  489.         if {$y + 10 > $othery} { set othery [expr {$y +10}] }
  490.         set y 100
  491.         incr x 190
  492.         eval lappend dial [dialog::text "continued…" $x y]
  493.         }
  494.         if {$items != "remove"} {
  495.         set t "Install $items"
  496.         } else {
  497.         set t "Remove obsolete files"
  498.         }
  499.         eval lappend dial [dialog::text $t $x y]
  500.         foreach item [set $items] {
  501.         lappend options [list $items $item]
  502.         regsub "\[/:\]\$" $item " ƒ" item
  503.         eval lappend dial [dialog::checkbox $item 1 [expr {$x + 20}] y]
  504.         if {$y > 360} {
  505.             set continue 1
  506.         }
  507.         }
  508.     }
  509.     }
  510.     incr y 10
  511.     set h [expr {$othery > $y ? $othery : $y}]
  512.     set yb [expr {$h - 70}]
  513.     set w [expr {390 + ($x/2)}]
  514.     set dials [list dialog -w $w -h $h]
  515.     set y 10
  516.     eval lappend dials [dialog::text "$pkgname installation options" 20 y 35]
  517.     eval lappend dials [dialog::button "OK" [expr {$w -80}] yb]
  518.     eval lappend dials [dialog::button "Cancel" [expr {$w -80}] yb]
  519.     set res [eval [concat $dials [list -m [concat [list [lindex $names 0]] $names] 250 10 405 30]  $dial]]
  520.     if {[lindex $res 1]} { error "Cancel" } 
  521.     # cancel was pressed
  522.     set easy_install [expr {1 - [lsearch $names [lindex $res 2]]}]
  523.     if {$easy_install} {
  524.     set make_backup [lindex $res 3]
  525.     set make_log [lindex $res 4]
  526.     set install::force_overwrite [lindex $res 5]
  527.     } else {
  528.     set make_backup [lindex $res 6]
  529.     set make_log [lindex $res 7]
  530.     set install::force_overwrite [lindex $res 8]
  531.     }
  532.     if {$make_backup} {
  533.     global HOME
  534.     set make_backup [file join $HOME InstallationBackup]
  535.     } else {
  536.     set make_backup ""
  537.     }
  538.     # Set i to 8 because it is first incremented below,
  539.     # so installation goes from 9 to end, if we're not
  540.     # doing an easy install.
  541.     set i 8
  542.     global install::_ignore install::log install::nochanges
  543.     set install::_ignore $opts(-ignore)
  544.     set install::log ""
  545.     set install::nochanges 1
  546.     foreach o $options {
  547.     incr i
  548.     if {!$easy_install && ![lindex $res $i]} { continue }
  549.     set type [lindex $o 0]
  550.     set name [lindex $o 1]
  551.     message "Installing $type '$name'"
  552.     install::files $type $currD $name $make_backup
  553.     }
  554.     unset install::_ignore
  555.     if {${install::log} == ""} {
  556.     alertnote "No changes were made.  You must have already\
  557.       installed this package."
  558.     } else {
  559.     if {$make_log} {
  560.         install::showLog
  561.     } else {
  562.         unset install::log
  563.     }
  564.     }
  565.  
  566. }
  567.  
  568. proc install::showLog {{title "Installation report"}} {
  569.     global install::log
  570.     new -g 0 160 640 300 -n $title -text "${install::log}End of report." \
  571.       -read-only 1 -dirty 0
  572.     unset install::log
  573. }
  574.  
  575.  
  576. # Install 'name' from $currD into where it should go    
  577. # If 'name' ends in a colon, it's a directory.  We can just 
  578. # use glob to get a list!
  579. proc install::files {type from name backup} {
  580.     global HOME PREFS tclExtensionsFolder file::separator
  581.     set flist [glob -nocomplain [file join $from [string trimright $name ":/"] *]]
  582.     if {![llength $flist] && [file exists [file join $from $name]] \
  583.       && [file isfile [file join $from $name]]} {
  584.     lappend flist [file join $from $name]
  585.     }
  586.     switch -- $type {
  587.     Tests -
  588.     Tools {
  589.         set to [file join ${HOME} $type]
  590.         foreach f $flist {
  591.         install::file_to $f $to $backup
  592.         }        
  593.     }        
  594.     remove {
  595.         if {![catch {file::standardFind $name} what]} {
  596.         if {[regexp "(/|:)\$" $name]} {
  597.             foreach f [glob -nocomplain -path $what *] {
  598.             file::removeOne $f $backup
  599.             }
  600.             install::log "Removed dir: $name"
  601.             file delete $what
  602.         } else {
  603.             file::removeOne $what $backup
  604.         }
  605.         }
  606.     }
  607.     SystemCode -
  608.     Modes -
  609.     Menus - 
  610.     Packages {
  611.         set to [file join ${HOME} Tcl ${type}]
  612.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  613.         install::file_to $name $to
  614.         set to [file join $to [string trimright ${name} ":/"]]
  615.         }
  616.         foreach f $flist {
  617.         install::file_to $f $to $backup
  618.         }        
  619.     }
  620.     AlphaCore {
  621.         set to [file join ${HOME} AlphaCore]
  622.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  623.         install::file_to $name $to
  624.         set to [file join $to [file dirname $name]]
  625.         }
  626.         foreach f $flist {
  627.         install::file_to $f $to $backup
  628.         }        
  629.     }
  630.     CorePackages {
  631.         set to [file join ${HOME} Tcl SystemCode CorePackages]
  632.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  633.         install::file_to $name $to
  634.         set to [file join $to [file dirname $name]]
  635.         }
  636.         foreach f $flist {
  637.         install::file_to $f $to $backup
  638.         }        
  639.     }
  640.     QuickStart {
  641.         set to [file join ${HOME} QuickStart]
  642.         foreach f $flist {
  643.         install::file_to $f $to $backup
  644.         install::readAtStartup [file join ${HOME} QuickStart [file tail $f]]
  645.         }        
  646.     }
  647.     Home {
  648.         set to "${HOME}"
  649.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  650.         install::file_to $name $to
  651.         set to [file join $to [file dirname $name]]
  652.         }
  653.         foreach f $flist {
  654.         install::file_to $f $to $backup
  655.         }        
  656.     }
  657.     SharedLibs {
  658.         set to $HOME
  659.         foreach f $flist {
  660.         install::file_to $f $to $backup
  661.         }        
  662.     }
  663.     Help {
  664.         set to [file join ${HOME} $type]
  665.         foreach f $flist {
  666.         install::file_to $f $to $backup
  667.         }        
  668.     }
  669.     Examples {
  670.         set to [file join ${HOME} "Mode Examples"]
  671.         foreach f $flist {
  672.         install::file_to $f $to $backup
  673.         }        
  674.     }        
  675.     BugFixes {
  676.         foreach f $flist {
  677.         procs::patchOriginalsFromFile $f 0
  678.         install::log "Installed patches from $f"
  679.         }
  680.     }
  681.     Completions {
  682.         set to [file join ${HOME} Tcl Completions]
  683.         foreach f $flist {
  684.         install::file_to $f $to $backup
  685.         }        
  686.     }
  687.     UserModifications {
  688.         set to [file join ${HOME} Tcl UserModifications]
  689.         global install::noreplace
  690.         set install::noreplace 1
  691.         foreach f $flist {
  692.         install::file_to $f $to $backup
  693.         }        
  694.         set install::noreplace 0
  695.     }        
  696.     ExtensionsCode {
  697.         if {![info exists tclExtensionsFolder]} {
  698.         set tclExtensionsFolder $PREFS
  699.         alertnote "This installation contains extension\
  700.           (+.tcl) files.  These require\
  701.           the 'Smarter Source' package, which you do not have\
  702.           installed.  I've put the extension\
  703.           files in your prefs directory, but they will not operate\
  704.           without that package."
  705.         }
  706.         set to "$tclExtensionsFolder"
  707.         foreach f $flist {
  708.         install::file_to $f $to $backup
  709.         }
  710.     }    
  711.     }
  712.     message "File installation complete"
  713. }
  714.  
  715. proc install::log {text} {
  716.     global install::log install::nochanges
  717.     append install::log "${text}\r"
  718.     if {![string match "The pre-exist*" $text]} {
  719.     set install::nochanges 0
  720.     }
  721. }
  722.  
  723. proc install::file_to {file to {backup ""}} {
  724.     if {[file tail $file] == "Iconm"} {return}
  725.     if {[regexp -nocase {tutorial$} [file tail $file]]} {
  726.     global HOME
  727.     install::_file_to $file [file join $HOME Tcl Completions]
  728.     } elseif {[regexp -nocase {help$} [file tail $file]] \
  729.       || ([file tail $file] == "Changes")} {
  730.     global HOME
  731.     install::_file_to $file [file join $HOME Help] $backup
  732.     } elseif {[regexp {\+[0-9]*.tcl} [file tail $file]]} {
  733.     global tclExtensionsFolder PREFS
  734.     if {![info exists tclExtensionsFolder]} { set tclExtensionsFolder $PREFS }
  735.     install::_file_to $file $tclExtensionsFolder $backup
  736.     } else {
  737.     if {[file isdirectory $file]} {
  738.         set to [file join ${to} [file tail $file]]
  739.         if {[file exists $to]} {
  740.         if {![file isdirectory $to]} {
  741.             file::remove [file dirname $to] [list [file tail $to]] $backup
  742.             install::log "Removed '$to' to make room for a directory with the same name"
  743.             file mkdir $to
  744.         }
  745.         } else {
  746.         file mkdir $to
  747.         }
  748.         foreach f [glob -nocomplain -dir $file *] {
  749.         install::file_to $f $to $backup
  750.         }
  751.     } else {
  752.         install::_file_to $file $to $backup
  753.     }
  754.     }
  755. }
  756.  
  757. proc install::_file_to {file to {backup ""}} {
  758.     global install::_ignore file::separator install::force_overwrite
  759.     foreach suffix ${install::_ignore} {
  760.     if {[string match *${file::separator}${suffix} $file] \
  761.       || [string match ${suffix} $file]} {
  762.         return
  763.     }
  764.     }
  765.     message "Installing [file tail $file]"
  766.     if {[file::ensureDirExists $to]} {
  767.     install::log "Created dir '$to'"
  768.     }
  769.     if {[regexp "(/|:)\$" $file]} {
  770.     # Install a directory
  771.     if {[file::ensureDirExists [file join ${to} [file tail [file dirname $file]]]]} {
  772.         install::log "Created dir '[file join ${to} [file tail [file dirname $file]]]'"
  773.     }
  774.     return
  775.     }
  776.     set files [glob -nocomplain -path $file *]
  777.  
  778.     global install::noreplace
  779.     if {[info exists install::noreplace] && ${install::noreplace}} {
  780.     foreach ff $files {
  781.         foreach suffix ${install::_ignore} {
  782.         if {[string match *${suffix} $file]} { continue }
  783.         }
  784.         set f [file tail $ff]
  785.         if {![file exists [file join $to $f]]} {
  786.         if {[file exists "$ff" ]} {
  787.             file copy "$ff" [file join $to $f]
  788.             install::fixLineEndings [file join $to $f]
  789.             install::log "Copied '[file tail $ff]' to '[file join $to $f]'"
  790.         }
  791.         }
  792.     }
  793.     } else {
  794.     foreach ff $files {
  795.         foreach suffix ${install::_ignore} {
  796.         if {[string match *${suffix} $file]} { continue }
  797.         }
  798.         set f [file tail $ff]
  799.         
  800.         if {[regexp "tclIndexx?" [file tail $f]]} {
  801.         continue
  802.         }
  803.         
  804.         if {${install::force_overwrite}} {
  805.         if {[file exists "$ff" ]} {
  806.             file::remove $to [list $f] $backup
  807.             file copy "$ff" [file join $to $f]
  808.             install::fixLineEndings [file join $to $f]
  809.             install::log "Overwrote from '[file tail $ff]' to '[file join $to $f]'"
  810.         }
  811.         } else {
  812.         file::replaceSecondIfOlder "$ff" [file join ${to} $f] 0 $backup
  813.         }
  814.     }
  815.     }
  816. }
  817.  
  818. proc install::fixLineEndings {f} {
  819.     if {([info tclversion] >= 8.0) || ([file extension $f] != ".tcl")} {return}
  820.     set fd [open $f "r"]
  821.     set text [read $fd]
  822.     close $fd
  823.     if {[regsub -all "\n" $text "\r" text]} {
  824.     # Only re-write the file if it had bad line-endings.
  825.     set fd [open $f "w"]
  826.     puts -nonewline $fd $text
  827.     close $fd
  828.     }
  829. }
  830.  
  831.